home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacGambit 2.0 / sources2 / Interp⁄Comp (.scm) / ptree2.scm < prev    next >
Encoding:
Text File  |  1992-06-04  |  21.7 KB  |  637 lines  |  [TEXT/gamI]
  1. ;==============================================================================
  2.  
  3. ; file: "ptree2.scm"
  4.  
  5. ;------------------------------------------------------------------------------
  6. ;
  7. ; Parse tree manipulation package: (part 2)
  8. ; -------------------------------
  9.  
  10. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  11.  
  12. (define (normalize-parse-tree ptree env)
  13.  
  14.   (define (normalize ptree)
  15.     (let ((tree (assignment-convert (partial-evaluate ptree) env)))
  16.       (lambda-lift! tree)
  17.       tree))
  18.  
  19.   (if (def? ptree)
  20.     (begin
  21.       (node-children-set! ptree (list (normalize (def-val ptree))))
  22.       ptree)
  23.     (normalize ptree)))
  24.  
  25. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  26. ;
  27. ; Partial evaluation:
  28. ; ------------------
  29.  
  30. ; (partial-evaluate ptree) returns a parse-tree equivalent to 'ptree' but
  31. ; with constants propagated through the parse-tree.
  32. ; Presently, very little folding of primitive operations is done.
  33.  
  34. (define (partial-evaluate ptree)
  35.   (pe ptree '()))
  36.  
  37. (define (pe ptree consts)
  38.  
  39.   (cond ((cst? ptree)
  40.          (new-cst (node-source ptree) (node-decl ptree) (cst-val ptree)))
  41.  
  42.         ((ref? ptree)
  43.          (let ((var (ref-var ptree)))
  44.            (var-refs-set! var (set-remove (var-refs var) ptree))
  45.            (let ((x (assq var consts)))
  46.              (if x
  47.                (new-cst (node-source ptree) (node-decl ptree) (cdr x))
  48.                (let ((y (global-val var)))
  49.                  (if (and y (cst? y))
  50.                    (new-cst (node-source ptree) (node-decl ptree) (cst-val y))
  51.                    (new-ref (node-source ptree) (node-decl ptree) var)))))))
  52.  
  53.         ((set? ptree)
  54.          (let ((var (set-var ptree))
  55.                (val (pe (set-val ptree) consts)))
  56.            (var-sets-set! var (set-remove (var-sets var) ptree))
  57.            (new-set (node-source ptree) (node-decl ptree)
  58.              var
  59.              val)))
  60.  
  61.         ((tst? ptree)
  62.          (let ((pre (pe (tst-pre ptree) consts)))
  63.            (if (cst? pre)
  64.              (let ((val (cst-val pre)))
  65.                (if (false-object? val)
  66.                  (pe (tst-alt ptree) consts)
  67.                  (pe (tst-con ptree) consts)))
  68.              (new-tst (node-source ptree) (node-decl ptree)
  69.                pre
  70.                (pe (tst-con ptree) consts)
  71.                (pe (tst-alt ptree) consts)))))
  72.  
  73.         ((conj? ptree)
  74.          (let ((pre (pe (conj-pre ptree) consts)))
  75.            (if (cst? pre)
  76.              (let ((val (cst-val pre)))
  77.                (if (false-object? val)
  78.                  pre
  79.                  (pe (conj-alt ptree) consts)))
  80.              (new-conj (node-source ptree) (node-decl ptree)
  81.                pre
  82.                (pe (conj-alt ptree) consts)))))
  83.  
  84.         ((disj? ptree)
  85.          (let ((pre (pe (disj-pre ptree) consts)))
  86.            (if (cst? pre)
  87.              (let ((val (cst-val pre)))
  88.                (if (false-object? val)
  89.                  (pe (disj-alt ptree) consts)
  90.                  pre))
  91.              (new-disj (node-source ptree) (node-decl ptree)
  92.                pre
  93.                (pe (disj-alt ptree) consts)))))
  94.  
  95.         ((prc? ptree)
  96.          (new-prc (node-source ptree) (node-decl ptree)
  97.            (prc-name ptree)
  98.            (prc-min ptree)
  99.            (prc-rest ptree)
  100.            (prc-parms ptree)
  101.            (pe (prc-body ptree) consts)))
  102.  
  103.         ((app? ptree)
  104.          (let ((oper (app-oper ptree))
  105.                (args (app-args ptree)))
  106.            (if (and (prc? oper) ; applying a lambda-expr is like a 'let'
  107.                     (not (prc-rest oper))
  108.                     (= (length (prc-parms oper)) (length args)))
  109.              (pe-let ptree consts)
  110.              (new-call (node-source ptree) (node-decl ptree)
  111.                (pe oper consts)
  112.                (map (lambda (x) (pe x consts)) args)))))
  113.  
  114.         ((fut? ptree)
  115.          (new-fut (node-source ptree) (node-decl ptree)
  116.            (pe (fut-val ptree) consts)))
  117.  
  118.         (else
  119.          (compiler-internal-error "pe, unknown parse tree node type"))))
  120.  
  121. (define (pe-let ptree consts)
  122.   (let* ((proc (app-oper ptree))
  123.          (vals (app-args ptree))
  124.          (vars (prc-parms proc))
  125.          (non-mut-vars (set-keep not-mutable? (list->set vars))))
  126.  
  127.     (for-each (lambda (var)
  128.                 (var-refs-set! var (set-empty))
  129.                 (var-sets-set! var (set-empty)))
  130.               vars)
  131.  
  132.     (let loop ((l vars)
  133.                (v vals)
  134.                (new-vars '())
  135.                (new-vals '())
  136.                (new-consts consts))
  137.       (if (null? l)
  138.  
  139.         (if (null? new-vars)
  140.           (pe (prc-body proc) new-consts)
  141.           (new-call (node-source ptree) (node-decl ptree)
  142.             (new-prc (node-source proc) (node-decl proc)
  143.               #f
  144.               (length new-vars)
  145.               #f
  146.               (reverse new-vars)
  147.               (pe (prc-body proc) new-consts))
  148.             (reverse new-vals)))
  149.  
  150.         (let ((var (car l))
  151.               (val (pe (car v) consts)))
  152.  
  153.           (if (and (set-member? var non-mut-vars) (cst? val))
  154.  
  155.             (loop (cdr l)
  156.                   (cdr v)
  157.                   new-vars
  158.                   new-vals
  159.                   (cons (cons var (cst-val val)) new-consts))
  160.  
  161.             (loop (cdr l)
  162.                   (cdr v)
  163.                   (cons var new-vars)
  164.                   (cons val new-vals)
  165.                   new-consts)))))))
  166.  
  167. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  168. ;
  169. ; Assignment conversion:
  170. ; ---------------------
  171.  
  172. ; (assignment-convert ptree env) returns a parse-tree equivalent to 'ptree' but
  173. ; containing no assignments to non-global variables.  In the converted
  174. ; parse-tree, 'cells' are used to implement mutable variables and calls to
  175. ; the procedures:
  176. ;
  177. ;   ##MAKE-CELL, ##CELL-REF, ##CELL-SET!
  178. ;
  179. ; are added to create and access the cells.  'env' is the global environment
  180. ; in which 'ptree' is parsed.
  181.  
  182. (define (assignment-convert ptree env)
  183.   (ac ptree (env-declare env (list SAFE-sym #f)) '()))
  184.  
  185. (define (ac ptree env mut)
  186.  
  187.   (cond ((cst? ptree)
  188.          ptree)
  189.  
  190.         ((ref? ptree)
  191.          (let ((var (ref-var ptree)))
  192.            (if (global? var)
  193.              ptree
  194.              (let ((x (assq var mut)))
  195.                (if x
  196.                  (let ((source (node-source ptree)))
  197.                    (var-refs-set! var (set-remove (var-refs var) ptree))
  198.                    (new-call source (node-decl ptree)
  199.                      (new-ref-extended-bindings source **CELL-REF-sym env)
  200.                      (list (new-ref source (node-decl ptree) (cdr x)))))
  201.                  ptree)))))
  202.  
  203.         ((set? ptree)
  204.          (let ((var (set-var ptree))
  205.                (source (node-source ptree))
  206.                (val (ac (set-val ptree) env mut)))
  207.            (var-sets-set! var (set-remove (var-sets var) ptree))
  208.            (if (global? var)
  209.              (new-set source (node-decl ptree)
  210.                var
  211.                val)
  212.              (new-call source (node-decl ptree)
  213.                (new-ref-extended-bindings source **CELL-SET!-sym env)
  214.                (list (new-ref source (node-decl ptree) (cdr (assq var mut)))
  215.                      val)))))
  216.  
  217.         ((tst? ptree)
  218.          (new-tst (node-source ptree) (node-decl ptree)
  219.            (ac (tst-pre ptree) env mut)
  220.            (ac (tst-con ptree) env mut)
  221.            (ac (tst-alt ptree) env mut)))
  222.  
  223.         ((conj? ptree)
  224.          (new-conj (node-source ptree) (node-decl ptree)
  225.            (ac (conj-pre ptree) env mut)
  226.            (ac (conj-alt ptree) env mut)))
  227.  
  228.         ((disj? ptree)
  229.          (new-disj (node-source ptree) (node-decl ptree)
  230.            (ac (disj-pre ptree) env mut)
  231.            (ac (disj-alt ptree) env mut)))
  232.  
  233.         ((prc? ptree)
  234.          (ac-proc ptree env mut))
  235.  
  236.         ((app? ptree)
  237.          (let ((oper (app-oper ptree))
  238.                (args (app-args ptree)))
  239.            (if (and (prc? oper) ; applying a lambda-expr is like a 'let'
  240.                     (not (prc-rest oper))
  241.                     (= (length (prc-parms oper)) (length args)))
  242.              (ac-let ptree env mut)
  243.              (new-call (node-source ptree) (node-decl ptree)
  244.                (ac oper env mut)
  245.                (map (lambda (x) (ac x env mut)) args)))))
  246.  
  247.         ((fut? ptree)
  248.          (new-fut (node-source ptree) (node-decl ptree)
  249.            (ac (fut-val ptree) env mut)))
  250.  
  251.         (else
  252.          (compiler-internal-error "ac, unknown parse tree node type"))))
  253.  
  254. (define (ac-proc ptree env mut)
  255.   (let* ((mut-parms (ac-mutables (prc-parms ptree)))
  256.          (mut-parms-copies (map var-copy mut-parms))
  257.          (mut (append (pair-up mut-parms mut-parms-copies) mut))
  258.          (new-body (ac (prc-body ptree) env mut)))
  259.  
  260.     (new-prc (node-source ptree) (node-decl ptree)
  261.       (prc-name ptree)
  262.       (prc-min ptree)
  263.       (prc-rest ptree)
  264.       (prc-parms ptree)
  265.       (if (null? mut-parms)
  266.         new-body
  267.         (new-call (node-source ptree) (node-decl ptree)
  268.           (new-prc (node-source ptree) (node-decl ptree)
  269.             #f
  270.             (length mut-parms-copies)
  271.             #f
  272.             mut-parms-copies
  273.             new-body)
  274.           (map (lambda (var)
  275.                  (new-call (var-source var) (node-decl ptree)
  276.                    (new-ref-extended-bindings (var-source var) **MAKE-CELL-sym env)
  277.                    (list (new-ref (var-source var) (node-decl ptree) var))))
  278.                mut-parms))))))
  279.  
  280. (define (ac-let ptree env mut)
  281.   (let* ((proc (app-oper ptree))
  282.          (vals (app-args ptree))
  283.          (vars (prc-parms proc))
  284.          (vals-fv (apply set-union (map free-variables vals)))
  285.          (mut-parms (ac-mutables vars))
  286.          (mut-parms-copies (map var-copy mut-parms))
  287.          (mut (append (pair-up mut-parms mut-parms-copies) mut)))
  288.          
  289.     (let loop ((l vars)
  290.                (v vals)
  291.                (new-vars '())
  292.                (new-vals '())
  293.                (new-body (ac (prc-body proc) env mut)))
  294.       (if (null? l)
  295.  
  296.         (new-let ptree proc new-vars new-vals new-body)
  297.  
  298.         (let ((var (car l))
  299.               (val (car v)))
  300.  
  301.           (if (memq var mut-parms)
  302.  
  303.             (let ((src (node-source val))
  304.                   (decl (node-decl val))
  305.                   (var* (cdr (assq var mut))))
  306.  
  307.               (if (set-member? var vals-fv)
  308.  
  309.                 (loop (cdr l)
  310.                       (cdr v)
  311.                       (cons var* new-vars)
  312.                       (cons (new-call src decl
  313.                               (new-ref-extended-bindings src **MAKE-CELL-sym env)
  314.                               (list (new-cst src decl undef-object)))
  315.                             new-vals)
  316.                       (new-seq src decl
  317.                         (new-call src decl
  318.                           (new-ref-extended-bindings src **CELL-SET!-sym env)
  319.                           (list (new-ref src decl var*)
  320.                                 (ac val env mut)))
  321.                         new-body))
  322.  
  323.                 (loop (cdr l)
  324.                       (cdr v)
  325.                       (cons var* new-vars)
  326.                       (cons (new-call src decl
  327.                               (new-ref-extended-bindings src **MAKE-CELL-sym env)
  328.                               (list (ac val env mut)))
  329.                             new-vals)
  330.                       new-body)))
  331.  
  332.             (loop (cdr l)
  333.                   (cdr v)
  334.                   (cons var new-vars)
  335.                   (cons (ac val env mut) new-vals)
  336.                   new-body)))))))
  337.  
  338. (define (ac-mutables l)
  339.   (if (pair? l)
  340.     (let ((var (car l)) (rest (ac-mutables (cdr l))))
  341.       (if (mutable? var)
  342.         (cons var rest)
  343.         rest))
  344.     '()))
  345.  
  346. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  347. ;
  348. ; Lambda-lifting procedure:
  349. ; ------------------------
  350.  
  351. ; (lambda-lift! ptree) modifies the parse-tree 'ptree' so that some
  352. ; of its procedures (i.e. lambda-expressions) are replaced with
  353. ; weaker ones (i.e. lambda-expressions having fewer or no closed variables).
  354. ; It is assumed that 'ptree' has been assignment-converted.
  355. ; Presently, only named procedures are lambda-lifted.
  356.  
  357. (define (lambda-lift! ptree)
  358.   (ll! ptree (set-empty) '()))
  359.  
  360. (define (ll! ptree cst-procs env)
  361.  
  362.   (define (new-env env vars)
  363.     (define (loop i l)
  364.       (if (pair? l)
  365.         (let ((var (car l)))
  366.           (cons (cons var (cons (length (set->list (var-refs var))) i))
  367.                 (loop (+ i 1) (cdr l))))
  368.         env))
  369.     (loop (length env) vars))
  370.  
  371.   (cond ((or (cst? ptree)
  372.              (ref? ptree)
  373.              (set? ptree)
  374.              (tst? ptree)
  375.              (conj? ptree)
  376.              (disj? ptree)
  377.              (fut? ptree))
  378.          (for-each (lambda (child) (ll! child cst-procs env))
  379.                    (node-children ptree)))
  380.  
  381.         ((prc? ptree)
  382.          (ll! (prc-body ptree) cst-procs (new-env env (prc-parms ptree))))
  383.  
  384.         ((app? ptree)
  385.          (let ((oper (app-oper ptree))
  386.                (args (app-args ptree)))
  387.            (if (and (prc? oper) ; applying a lambda-expr is like a 'let'
  388.                     (not (prc-rest oper))
  389.                     (= (length (prc-parms oper)) (length args)))
  390.              (ll!-let ptree cst-procs (new-env env (prc-parms oper)))
  391.              (for-each (lambda (child) (ll! child cst-procs env))
  392.                        (node-children ptree)))))
  393.  
  394.         (else
  395.          (compiler-internal-error "ll!, unknown parse tree node type"))))
  396.  
  397. (define (ll!-let ptree cst-procs env)
  398.   (let* ((proc (app-oper ptree))
  399.          (vals (app-args ptree))
  400.          (vars (prc-parms proc))
  401.          (var-val-map (pair-up vars vals)))
  402.  
  403.     (define (var->val var) (cdr (assq var var-val-map)))
  404.  
  405.     (define (liftable-proc-vars vars)
  406.       (let loop ((cst-proc-vars
  407.                    (set-keep (lambda (var)
  408.                                (let ((val (var->val var)))
  409.                                  (and (prc? val)
  410.                                       (lambda-lift? (node-decl val))
  411.                                       (set-every? oper-pos? (var-refs var)))))
  412.                              (list->set vars))))
  413.         (let* ((non-cst-proc-vars
  414.                  (set-keep (lambda (var)
  415.                              (let ((val (var->val var)))
  416.                                (and (prc? val)
  417.                                     (not (set-member? var cst-proc-vars)))))
  418.                            (list->set vars)))
  419.                (cst-proc-vars*
  420.                  (set-keep (lambda (var)
  421.                              (let ((val (var->val var)))
  422.                                (set-empty?
  423.                                  (set-intersection (free-variables val)
  424.                                                    non-cst-proc-vars))))
  425.                            cst-proc-vars)))
  426.           (if (set-equal? cst-proc-vars cst-proc-vars*)
  427.             cst-proc-vars
  428.             (loop cst-proc-vars*)))))
  429.         
  430.     (let* ((cst-proc-vars (liftable-proc-vars vars))
  431.            (cst-proc-vars-list (set->list cst-proc-vars))
  432.            (cst-procs* (set-union cst-proc-vars cst-procs))
  433.            (var-tcfv-map
  434.              (map (lambda (var) (cons var (free-variables (var->val var))))
  435.                   cst-proc-vars-list)))
  436.  
  437.       (define (var->tcfv var) (cdr (assq var var-tcfv-map)))
  438.  
  439.       (define (order-vars vars)
  440.         (map car
  441.              (sort-list (map (lambda (var) (assq var env)) vars)
  442.                         (lambda (x y)
  443.                           (if (= (cadr x) (cadr y))
  444.                             (< (cddr x) (cddr y))
  445.                             (< (cadr x) (cadr y)))))))
  446.  
  447.       (define (lifted-vars var)
  448.         (order-vars (set->list (set-difference (var->tcfv var) cst-procs*))))
  449.  
  450.       (define (lift-app! var)
  451.         (let* ((val (var->val var))
  452.                (vars (lifted-vars var)))
  453.  
  454.           (define (new-ref* var)
  455.             (new-ref (var-source var) (node-decl val) var))
  456.  
  457.           (if (not (null? vars))
  458.             (for-each (lambda (oper)
  459.                         (let ((node (node-parent oper)))
  460.                           (node-children-set! node
  461.                             (cons (app-oper node)
  462.                                   (append (map new-ref* vars)
  463.                                           (app-args node))))))
  464.                       (set->list (var-refs var))))))
  465.  
  466.       (define (lift-prc! var)
  467.         (let* ((val (var->val var))
  468.                (vars (lifted-vars var)))
  469.  
  470.           (if (not (null? vars))
  471.             (let ((var-copies (map var-copy vars)))
  472.               (prc-parms-set! val (append var-copies (prc-parms val)))
  473.               (for-each (lambda (x) (var-bound-set! x val)) var-copies)
  474.               (node-fv-invalidate! val)
  475.               (prc-min-set! val (+ (prc-min val) (length vars)))
  476.               (ll-rename! val (pair-up vars var-copies))))))
  477.  
  478.       (let loop1 ((changed? #f))
  479.         (for-each (lambda (var-tcfv)
  480.                     (let loop2 ((l (set->list (cdr var-tcfv))) (fv (cdr var-tcfv)))
  481.                       (if (null? l)
  482.                         (if (not (set-equal? fv (cdr var-tcfv)))
  483.                           (begin
  484.                             (set-cdr! var-tcfv fv)
  485.                             (set! changed? #t)))
  486.                         (let ((x (assq (car l) var-tcfv-map)))
  487.                           (loop2 (cdr l)
  488.                                  (if x (set-union fv (cdr x)) fv))))))
  489.                   var-tcfv-map)
  490.  
  491.         (if changed?
  492.  
  493.           (loop1 #f)
  494.  
  495.           (begin
  496.             (for-each lift-app! cst-proc-vars-list)
  497.             (for-each lift-prc! cst-proc-vars-list)
  498.             (for-each (lambda (node) (ll! node cst-procs* env)) vals)
  499.             (ll! (prc-body proc) cst-procs* env)))))))
  500.  
  501. (define (ll-rename! ptree var-map)
  502.  
  503.   (cond ((ref? ptree)
  504.          (let* ((var (ref-var ptree))
  505.                 (x (assq var var-map)))
  506.            (if x
  507.              (begin
  508.                (var-refs-set! var (set-remove (var-refs var) ptree))
  509.                (var-refs-set! (cdr x) (set-adjoin (var-refs (cdr x)) ptree))
  510.                (ref-var-set! ptree (cdr x))))))
  511.  
  512.         ((set? ptree)
  513.          (let* ((var (set-var ptree))
  514.                 (x (assq var var-map)))
  515.            (if x
  516.              (begin
  517.                (var-sets-set! var (set-remove (var-sets var) ptree))
  518.                (var-sets-set! (cdr x) (set-adjoin (var-sets (cdr x)) ptree))
  519.                (set-var-set! ptree (cdr x)))))))
  520.  
  521.   (node-fv-set! ptree #t)
  522.  
  523.   (for-each (lambda (child) (ll-rename! child var-map))
  524.             (node-children ptree)))
  525.  
  526. ;------------------------------------------------------------------------------
  527. ;
  528. ; Debugging stuff:
  529.  
  530. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  531. ;
  532. ; (parse-tree->expression ptree) returns the Scheme expression corresponding to
  533. ; the parse tree 'ptree'.
  534.  
  535. (define (parse-tree->expression ptree)
  536.   (se ptree '() (list 0)))
  537.  
  538. (define (se ptree env num)
  539.  
  540.   (cond ((cst? ptree)
  541.          (list QUOTE-sym (cst-val ptree)))
  542.  
  543.         ((ref? ptree)
  544.          (let ((x (assq (ref-var ptree) env)))
  545.            (if x (cdr x) (var-name (ref-var ptree)))))
  546.  
  547.         ((set? ptree)
  548.          (list SET!-sym
  549.            (let ((x (assq (set-var ptree) env)))
  550.              (if x (cdr x) (var-name (set-var ptree))))
  551.            (se (set-val ptree) env num)))
  552.  
  553.         ((def? ptree)
  554.          (list DEFINE-sym
  555.            (let ((x (assq (def-var ptree) env)))
  556.              (if x (cdr x) (var-name (def-var ptree))))
  557.            (se (def-val ptree) env num)))
  558.  
  559.         ((tst? ptree)
  560.          (list IF-sym (se (tst-pre ptree) env num)
  561.                       (se (tst-con ptree) env num)
  562.                       (se (tst-alt ptree) env num)))
  563.  
  564.         ((conj? ptree)
  565.          (list AND-sym (se (conj-pre ptree) env num)
  566.                        (se (conj-alt ptree) env num)))
  567.  
  568.         ((disj? ptree)
  569.          (list OR-sym (se (disj-pre ptree) env num)
  570.                       (se (disj-alt ptree) env num)))
  571.  
  572.         ((prc? ptree)
  573.          (let ((new-env (se-rename (prc-parms ptree) env num)))
  574.            (list LAMBDA-sym
  575.              (se-parameters (prc-parms ptree)
  576.                             (prc-rest ptree)
  577.                             (prc-min ptree)
  578.                             new-env)
  579.              (se (prc-body ptree) new-env num))))
  580.  
  581.         ((app? ptree)
  582.          (let ((oper (app-oper ptree))
  583.                (args (app-args ptree)))
  584.            (if (and (prc? oper) ; applying a lambda-expr is like a 'let'
  585.                     (not (prc-rest oper))
  586.                     (= (length (prc-parms oper)) (length args)))
  587.              (let ((new-env (se-rename (prc-parms oper) env num)))
  588.                (list
  589.                  (if (set-empty?
  590.                        (set-intersection
  591.                          (list->set (prc-parms oper))
  592.                          (apply set-union (map free-variables args))))
  593.                    LET-sym
  594.                    LETREC-sym)
  595.                  (se-bindings (prc-parms oper) args new-env num)
  596.                  (se (prc-body oper) new-env num)))
  597.              (map (lambda (x) (se x env num)) (cons oper args)))))
  598.  
  599.         ((fut? ptree)
  600.          (list FUTURE-sym (se (fut-val ptree) env num)))
  601.  
  602.         (else
  603.          (compiler-internal-error "se, unknown parse tree node type"))))
  604.  
  605. (define (se-parameters parms rest min env)
  606.   (define (se-parms parms rest n env)
  607.     (cond ((null? parms)
  608.            '())
  609.           ((and rest (null? (cdr parms)))
  610.            (cdr (assq (car parms) env)))
  611.           (else
  612.            (let ((parm (cdr (assq (car parms) env))))
  613.              (cons (if (> n 0) parm (list parm))
  614.                    (se-parms (cdr parms) rest (- n 1) env))))))
  615.   (se-parms parms rest min env))
  616.  
  617. (define (se-bindings vars vals env num)
  618.   (if (null? vars)
  619.     '()
  620.     (cons (list (cdr (assq (car vars) env)) (se (car vals) env num))
  621.           (se-bindings (cdr vars) (cdr vals) env num))))
  622.  
  623. (define (se-rename vars env num)
  624.   (define (rename vars)
  625.     (if (null? vars)
  626.       env
  627.       (cons (cons (car vars)
  628.                   (string->canonical-symbol
  629.                     (string-append (symbol->string (var-name (car vars)))
  630.                                    "#"
  631.                                    (number->string (car num)))))
  632.             (rename (cdr vars)))))
  633.   (set-car! num (+ (car num) 1))
  634.   (rename vars))
  635.  
  636. ;==============================================================================
  637.